;;;
;;;  Legs16 VM for 6809
;;;     - Flat memory model
;;;     - no stack checking
;;;  	- no opcode security
;;;   	- no stack or memory bounds checking	

; MB	 equ   0x3000		; base address of memory store
                        	; MB must be set to a page boundary
; MEMZ	 equ   0x4000		; 16 k worth of virtual memory

  IFNDEF MB
      ERROR Symbol MB (memory base) must be defined and page aligned
  ENDC

  IFNDEF MEMZ
      ERROR Symbol MEMZ (memory size) must be defined
  ENDC

;;; Registers:
;;;    D  - scratch pad
;;;    X  - IP
;;;    Y  - scratch pad
;;;    U  - SP 
;;;    S  - RP 
;;;
;;; X,U,S hold an adjusted memory value - the values
;;; are adjusted with the offset to the base of the
;;; VM's memory store.
;;; 



;;; Register a extension Primitive
;;; entry: X is address of routine
;;; exit:  none
;;; mods:  all
rprim
	lslb			; convert op code into byte offset
        ldy	#table		; y is base of table
  	stx	d,y		; store address in table
	rts			; return

;;; This routine inits the Forth VM
;;; and starts the inner-interpreter
;;; entry: none
;;; exit:  doesn't
goforth
	;; we should clr the VM's memory....
	orcc	#0x50	     	; shut off interrupts 
	lds	#MEMZ+MB	; setup return pointer
	ldx	MB		; setup IP tp point to VM's reset vector
	leax	MB,x		; add memory store base to x
	ldu	#MEMZ+MB-0x80	; setup SP to point to end of memory store
	; clr	0x11a		; switch BASIC to lower case mode
	ldd	#int		; interrupt handler vector
	std	0x10d		; store in basic's irq routine
	andcc	#0xaf		; turn interrupts on
	jmp	next		; and jump to inner loop
	
push
	pulu	d		
	pshs	d
	bra	next

pull
	puls	d		
	pshu	d
	bra	next

drop				
	leau	2,u
	bra	next

dup				
	ldd	,u
	pshu	d
	bra	next

swap
	pulu	d
	pulu	y
	pshu	d
	pshu	y
	bra	next

over
	ldd	2,u
	pshu	d
	bra	next

bra
	ldx	,x
	leax	MB,x
	bra	next

zbra
	ldd	,u++
	beq	bra
	leax	2,x
	bra	next

dofor
	ldd	,s++
	beq	bra
	addd	#-1
	pshs	d
	leax	2,x
	bra	next

exit
	puls	x
	leax	MB,x
	bra	next

mint
	ldd	#0x8000
	pshu	d
	bra	next

and
	pulu	d
	anda	,u
	andb	1,u
	std	,u
	bra	next

or
	pulu	d
	ora	,u
	orb	1,u
	std	,u
	bra	next

xor
	pulu	d
	eora	,u
	eorb	1,u
	std	,u
	bra	next

com
	pulu	d
	coma
	comb
	pshu	d
	bra	next

plus
	pulu	d
	addd	,u
	std	,u
;	bra	next		; fall-through to next

next
	tst	iflag		; is there an interrupt pending?
	beq	next0		; nope 
	clr	iflag		; reset flag
	ldd	MB+2		; load d with interrupt vector
	bra	next1		; go processes vector
next0	ldd	,x++		; load next op code and inc IP
next1	tsta                    ; is a primitive?
	beq	next2		; yes then go processes
	leax	-MB,x		; no then change IP to virtual address
	pshs	x		; push virtual address onto RP
	adda	#MB/256		; convert op code to real address
	tfr	d,x		; store in IP
	bra	next		; rinse and repeat
next2
	lslb			; convert op code into byte offset
	tfr	d,y		; fetch op code address from table
	jmp	[table,y]	; go do primitive
	
shl
	pulu	d
	lslb
	rola
	pshu	d
	bra	next

shr
	pulu	d
	lsra
	rorb
	pshu	d
	bra	next

oneplus
	pulu	d
	addd	#1
	pshu	d
	bra	next

oneminus
	pulu	d
	addd	#-1
	pshu	d
	bra	next
	
spat
	leay	-MB,u
	pshu	y
	bra	next

spbang
	pulu	d
	adda	#MB/256
	tfr	d,u
	bra	next

rpat
	leay	-MB,s
	pshu	y
	bra	next

rpbang
	pulu	d
	adda	#MB/256
	tfr	d,s
	bra	next

exec
	pulu	d
	bra	next1

at
	pulu	y
	ldd	MB,y
	pshu	d
	bra	next

bang
	pulu	y
	pulu	d
	std	MB,y
	bra	next

cat
	pulu	y
	clra
	ldb	MB,y
	pshu	d
	jmp	next

cbang
	pulu	y
	pulu	d
	stb	MB,y
	jmp	next

cell
	ldd	#2
	pshu	d
	jmp	next

char
	ldd	#1
	pshu	d
	jmp	next

lit
	ldd	,x++
	pshu	d
	jmp	next

key
	pshs 	cc
 	jsr 	0xa176 	; call BASIC's console in
 	puls 	cc
 	tfr 	a,b
 	clra
 	pshu 	d
	jmp	next

emit
	pshs 	cc
 	pulu 	d
 	tfr 	b,a
 	jsr 	0xa282 ; call BASIC's console out
 	puls 	cc
	jmp 	next

bye
	jmp	[0xfffe]

memz
	ldd	#MEMZ
	pshu	d
	jmp	next

pat
	clra
	ldb	[,u]
	std	,u
	jmp 	next

pbang
	pulu	y
	pulu	d
	stb	,y
	jmp	next


ion
	lda	#0xff
	sta	imask		; handle interrupts
	jmp	next

	
ioff
	clr	imask		; don't handle interrupts
	jmp	next

	;; real interrupt handler
int
	lda	0xff02	   	; reset pia
	tst	imask		; are we handling interrupt?
	beq	int1		; no then return
	lda	#0xff		; 
	sta	iflag		; set flag for syncronizing with main loop
int1	rti

imask	.db	0		; interrupt handler mask
iflag	.db	0		; marked true by interrupt handler
	



;;; This table holds the addresses of
;;; the Legs Forth VM
table
	.dw	bye		; This is the exception
	.dw	push
	.dw	pull
	.dw	drop
	.dw	dup
	.dw	swap		; 5
	.dw	over
	.dw	bra
	.dw	zbra
	.dw	dofor
	.dw	exit		; 10
	.dw	mint
	.dw	and
	.dw	or
	.dw	xor
	.dw	com		; 15
	.dw	plus
	.dw	shl
	.dw	shr
	.dw	oneplus
	.dw	oneminus	; 20
	.dw	spat
	.dw	spbang
	.dw	rpat
	.dw	rpbang
	.dw	exec		; 25
	.dw	at
	.dw	bang
	.dw	cat
	.dw	cbang
	.dw	cell		; 30
	.dw	char
	.dw	lit
	.dw	key
	.dw	emit
	.dw	bye		; 35
	.dw	memz
	.dw	pat		; 37
	.dw	pbang		; 38
	.dw	ion		; 39
	.dw	ioff		; 40
	IFDEF RAW
	zmb	table+256-.
	ELSE
	rmb	table+256-.
	ENDC